home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / assembler / ib.t < prev    next >
Text File  |  1988-02-05  |  13KB  |  331 lines
  1. (herald (assembler ib t 6))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. (define-structure-type ib
  27.   pos           ; position of this IB in vector of all IBs
  28.   sdf-number    ; records the sdf number of the align sdf, if any;
  29.                 ;  later, it records the number of sdfs that precede 
  30.                 ;  this ib. (used only by IB-FOLLOW, IB-ORDER stuff)
  31.  
  32.   address       ; address of block
  33.                 ; *** MULTIPLEXED w/ IB-PENDING-IBS
  34.  
  35.   align         ; <n> for specific number of bytes, or (<max> <n> <m>)
  36.                 ;  where <n> is alignment interval less 1, <m> is offset,
  37.                 ;  and <max> is the largest possible amount of space that 
  38.                 ;  this alignment will result in.  False means no alignment.
  39.  
  40.   instructions  ; list of fgs
  41.  
  42.   jump-op       ; number indicating EQ, GT, etc
  43.   1tag          ; IB to jump to if successful
  44.   0tag          ; IB to jump to if not successful
  45.  
  46.   next          ; the IB that may or must follow this one, if any.  This slot is 
  47.                 ;  for partial ordering IBs (like forcing the IB containing 
  48.                 ;  the instructions for a template to follow the IB with the
  49.                 ;  template in it; or to get ordering of blocks in a loop right)
  50.                 ;  The target of this field must have its POS slot
  51.                 ;  set to point to this IB.  If the link is provisional
  52.                 ;  then the pos slot should be set to (cons 'maybe <this-ib>)
  53.  
  54.   comments      ; alist, keyed by pairs taken from the ib-instructions list.
  55.                 ;  Comments will be printed after the fg in the car of the pair
  56.                 ;  is printed (in a listing).  Comments keyed by the null list
  57.                 ;  are printed before anything else.
  58.  
  59.   jumped-to-by  ; list of ibs that have a jump or fall through to this ib
  60.  
  61.   data-label?   ; true if this ib is the subject of a "data" reference
  62.                 ;   (and therefore can not be eliminated)
  63.  
  64.   name          ; for listings
  65.  
  66.   (((pretty-print self stream)
  67.      (pretty-print-ib self stream))))
  68.  
  69. (define-integrable ib-pending-ibs ib-address)
  70.  
  71. (let ((ib (stype-master ib-stype)))
  72.   (set (ib-pos ib) *empty*)
  73.  
  74.   (set (ib-pending-ibs ib) '())
  75.  
  76.   (set (ib-align ib) nil)
  77.   (set (ib-instructions ib) '())
  78.  
  79.   (set (ib-jump-op ib) *empty*)
  80.   (set (ib-1tag ib) *empty*)
  81.   (set (ib-0tag ib) *empty*)
  82.  
  83.   (set (ib-next ib) *empty*)
  84.   (set (ib-comments ib) '())
  85.  
  86.   (set (ib-jumped-to-by ib) '())
  87.   (set (ib-data-label?  ib) nil)
  88.  
  89.   (set (ib-name  ib) *empty*)
  90.   )
  91.  
  92.  
  93. (lset *pretty-print-tag* (undefined-value '*pretty-print-tag*))
  94.  
  95. (define (pretty-print-ib ib stream)
  96.   (*pretty-print-tag* ib stream))
  97.  
  98. ;;; One likely candidate for *pretty-print-tag*
  99.  
  100. (define (pp-ib-as-hash tag str)
  101.   (format str "~c~s" (if (ib-data-label? tag) #\D #\L) (object-hash tag)))
  102.  
  103. ;;; Another likely candidate for *pretty-print-tag*
  104.  
  105. (define (pp-ib-as-name-or-hash tag str)
  106.   (cond ((empty? (ib-name tag))
  107.          (format str "~c~s" (if (ib-data-label? tag) #\D #\L) (object-hash tag)))
  108.         (else
  109.          (format str "~a" (ib-name tag)))))
  110.      
  111. (define (set-ib-follower first-ib next-ib)
  112.   (let ((next-pos (ib-pos next-ib))
  113.         (first-next (ib-next first-ib)))
  114.     (cond ((not (empty? first-next))
  115.            ;; first has follower, but is it only provisional? 
  116.            (let ((old-back-link (ib-pos first-next)))
  117.              (cond ((and (pair? old-back-link) (eq? (car old-back-link) 'maybe))
  118.                     (set (ib-pos first-next) *empty*))
  119.                    (else
  120.                     (error "~s already has a follower~% (SET-IB-FOLLOWER ~s ~s)"
  121.                            first-ib
  122.                            first-ib
  123.                            next-ib)))))
  124.           ((not (empty? next-pos))
  125.            (cond ((and (pair? next-pos) (eq? (car next-pos) 'maybe))
  126.                   (set (ib-next (cdr next-pos)) *empty*))
  127.                  (else
  128.                   (error "~s already ordered~% (SET-IB-FOLLOWER ~s ~s)"
  129.                          next-ib
  130.                          first-ib
  131.                          next-ib)))))
  132.       (set (ib-next first-ib) next-ib)
  133.       (set (ib-pos next-ib) first-ib)))
  134.  
  135. (define (maybe-set-ib-follower first-ib next-ib)
  136.   (cond ((and (empty? (ib-pos next-ib))
  137.               (empty? (ib-next first-ib))
  138.               (not (eq? first-ib next-ib)))
  139.          (set (ib-next first-ib) next-ib)
  140.          (set (ib-pos next-ib) (cons 'maybe first-ib)))))
  141.  
  142.  
  143. ;;; CHOOSE BRANCH INSTRUCTIONS
  144.  
  145. ;;; This pass also reverses the instructions
  146.  
  147. (define (branchify ibv machine)
  148.   (let ((ibv-length (vector-length ibv))
  149.         (cond-branch (machine-cond-branch machine))
  150.         (uncond-branch (machine-uncond-branch machine)))
  151.     (do ((i 0 (fx+ i 1)))
  152.         ((fx>= i ibv-length)
  153.          ibv)
  154.       (let ((ib (vref ibv i))
  155.             (fall (cond ((fx< (fx+ i 1) ibv-length) (vref ibv (fx+ i 1)))
  156.                         (else nil))))
  157.         (cond ((empty? (ib-jump-op ib)))
  158.               ((empty? (ib-0tag ib))  ; abs jump
  159.                (cond ((eq? (ib-1tag ib) fall)
  160.                       (set (ib-jump-op ib) 'fall)
  161.                       (set (ib-1tag  ib) *empty*))
  162.                      (else 
  163.                       (set-branch ib (uncond-branch (ib-1tag ib)))
  164.                       )))
  165.               ((eq? fall (ib-0tag ib))
  166.                (set-branch ib (cond-branch (ib-jump-op ib) (ib-1tag ib)))
  167.                (set (ib-0tag ib) 'fall))
  168.               ((eq? fall (ib-1tag ib))
  169.                (set (ib-1tag ib) (ib-0tag ib))
  170.                (modify (ib-jump-op ib) reverse-jump)
  171.                (set-branch ib (cond-branch (ib-jump-op ib) (ib-1tag ib)))
  172.                (set (ib-0tag ib) 'fall))
  173.               ;; neither can fall through, both must jump
  174.               ;; if we knew sizes, we could jump to the closer one
  175.               (else 
  176.                (set-2-branches ib cond-branch uncond-branch)))
  177.         (modify (ib-comments ib) reverse!)
  178.         (modify (ib-instructions ib) reverse!)))))
  179.  
  180. (define (set-branch ib branch-fg)
  181.   (push (ib-instructions ib) (compress-fg branch-fg)))
  182.  
  183. (define (set-2-branches ib cond-branch uncond-branch)
  184.   (let ((1pos (ib-pos (ib-1tag ib)))
  185.         (0pos (ib-pos (ib-0tag ib)))
  186.         (pos (ib-pos ib)))
  187.     (receive (near far)
  188.              (cond ((fx< (fixnum-abs (fx- pos 1pos))
  189.                          (fixnum-abs (fx- pos 0pos)))
  190.                     (return 1pos 0pos))
  191.                    (else
  192.                     (return 0pos 1pos)))
  193.       (cond ((eq? far (ib-1tag ib))
  194.              (exchange (ib-1tag ib) (ib-0tag ib))
  195.              (modify (ib-jump-op ib) reverse-jump)))
  196.       (set-branch ib (cond-branch (ib-jump-op ib) (ib-1tag ib)))
  197.       (set-branch ib (uncond-branch (ib-0tag ib))))))
  198.  
  199. ;;;; ORDER INSTRUCTION BLOCKS (IB'S)
  200.  
  201. ;;; Given a list of ibs in the order generated, put them
  202. ;;; into a vector and set the POS field
  203.  
  204. (define-integrable (ib-free? ib)
  205.   (empty? (ib-pos ib)))
  206.  
  207. (define-integrable (ib-seen? ib)
  208.   (null? (ib-pos ib)))
  209.  
  210. (define-integrable (ib-ordered? ib)
  211.   (fixnum? (ib-pos ib)))
  212.  
  213. (define-integrable (ib-done? ib)
  214.   (and (fixnum? (ib-pos ib)) (fx>= (ib-pos ib) 0)))
  215.  
  216. (define (first-unordered-ib l)
  217.     (iterate loop ((l l))
  218.         (cond ((null? l) nil)
  219.               ((not (ib-ordered? (car l))) l)
  220.               (else
  221.                (loop (cdr l))))))
  222.  
  223. (lset *queued-ibs* nil)
  224. (lset *unqueued-ibs* nil)
  225.              
  226. (define (ib-order ibs)
  227.   ;; convert pos slots to a canonical mark for easy checking.
  228.   (walk (lambda (ib) (if (not (ib-free? ib)) (set (ib-pos ib) -1)))
  229.         ibs)
  230.   (bind ((*queued-ibs* 0) (*unqueued-ibs* 0))
  231.     (let ((ibv (make-vector (length ibs)))
  232.           (ibs (first-unordered-ib ibs)))
  233.       (iterate loop ((fall-to (car ibs)) (ibs (cdr ibs)) (pos 0))
  234.         (set (ib-pos fall-to) pos)
  235.         (set (vref ibv pos) fall-to)
  236.         (receive (winner loser)
  237.                  ;; check to see if a next is specified, if not choose one
  238.                  (cond ((empty? (ib-next fall-to))
  239.                         (ib-order-choose fall-to))
  240.                        (else
  241.                         (return (ib-next fall-to) nil)))
  242.           (let ((ibs (cond ((ib-pending-ibs fall-to) 
  243.                             => (lambda (x) (append! x ibs)))
  244.                            (else ibs))))
  245.             (cond (winner
  246.                    (if loser (set (ib-pos loser) nil))  ; mark as seen
  247.                    (loop winner ibs (fx+ pos 1)))
  248.                   (else
  249.                    (let ((ibs (next-free-ib ibs)))
  250.                       (cond ((null? ibs) 
  251.                              (noise "~s IBs queued, ~s IBs unqueued~%" 
  252.                                     *queued-ibs*
  253.                                     *unqueued-ibs*)
  254.                              ibv)
  255.                             (else 
  256.                              (loop (car ibs) (cdr ibs) (fx+ pos 1)))))))))))))
  257.  
  258. (define (next-free-ib ibs)
  259.   (iterate next-free ((ibs ibs))
  260.     (cond ((null? ibs) ibs)
  261.           (else
  262.            (let ((next (car ibs)))
  263.              (cond ((ib-ordered? next)
  264.                     (next-free (cdr ibs)))
  265.                    ((not (empty? (ib-jump-op next)))
  266.                     ibs)
  267.                    ;; dead end - so try to queue on pending-ibs of some ib
  268.                    (else
  269.                     (let ((froms (ib-jumped-to-by next)))
  270.                       (iterate queue ((froms froms) (q 0) (uq 0))
  271.                          (cond ((null? froms)
  272.                                 (set *queued-ibs* (fx+ *queued-ibs* q))
  273.                                 (set *unqueued-ibs* (fx+ *unqueued-ibs* uq))
  274.                                 (if (fx> q 0) (next-free (cdr ibs)) ibs))
  275.                                ((and (not (ib-done? (car froms)))
  276.                                      (empty? (ib-next (car froms))))
  277.                                 ;(format t "queue ~g on ~g~%~%" next (car froms))
  278.                                 (push (ib-pending-ibs (car froms)) next)
  279.                                 (queue (cdr froms) (fx+ q 1) uq))
  280.                                (else
  281.                                 ;(format t "didn't queue on ~g~% pos - ~s~% next - ~s~%~%" (car froms) (ib-pos (car froms)) (ib-next (car froms)))
  282.                                 (queue (cdr froms) q (fx+ uq 1)))))))
  283.                    ))))))
  284.  
  285.  
  286.  
  287. ;;; Returns 2 return, winner and loser.  If loser is null, then there is
  288. ;;; one alternative, if winner is null, there is no alternative.
  289. (define (ib-order-choose ib)
  290.   (let ((0tag (ib-0tag ib))
  291.         (1tag (ib-1tag ib)))
  292.     (cond ((empty? (ib-jump-op ib))
  293.            (return nil nil))
  294.           ((empty? 0tag)
  295.            (return (if (ib-ordered? 1tag) nil 1tag)
  296.                    nil))
  297.           ((and (ib-ordered? 0tag) (not (ib-ordered? 1tag)))
  298.            (return 1tag nil))
  299.           ((and (ib-ordered? 1tag) (not (ib-ordered? 0tag)))
  300.            (return 0tag nil))
  301.           ;; they are both ordered, or both not
  302.           ((ib-ordered? 0tag)
  303.            (return nil nil))
  304.           ;; both unordered
  305.           ((fx> (ib-situation 0tag) (ib-situation 1tag))
  306.            (return 0tag 1tag))
  307.           (else
  308.            (return 1tag 0tag)))))
  309.  
  310. ;;; This should take into account whether or not the IB-NEXT slot is filled 
  311. (define (ib-situation ib)
  312.   (cond ((empty? (ib-jump-op ib)) 0)
  313.         ((empty? (ib-0tag ib))  ; means block ends in unconditional jump
  314.          (cond ((ib-free? (ib-1tag ib))
  315.                 6)    ;1 exit, free future
  316.                ((ib-seen? (ib-1tag ib))
  317.                 7)    ;1 exit, already queued
  318.                (else
  319.                 1)))
  320.         (else
  321.          (let ((1ordered? (ib-ordered? (ib-1tag ib)))
  322.                (0ordered? (ib-ordered? (ib-0tag ib))))
  323.            (cond ((and (not 1ordered?) (not 0ordered?))
  324.                   3)  
  325.                  ((and 1ordered? 0ordered?)
  326.                   2)   
  327.                  ((or (ib-seen? (ib-0tag ib)) (ib-seen? (ib-1tag ib)))
  328.                   5)
  329.                  (else
  330.                   4))))))
  331.